perm filename MKCON[2,BGB] blob
sn#033829 filedate 1973-04-09 generic text, type T, neo UTF8
00100 ;MAKE CONTOUR IMAGE.
00200 TITLE MKCON
00300
00400 EXTERN FLGARC,FLGBK,FTVSIX,FLGKRK,FLGU
00500 EXTERN FTVHIS,ARCWID,CTRL,META
00600 EXTERN PAC,STADPY,TVBUF,SEGTV
00700 EXTERN HISTO,HSEG,VSEG,FILM,SKYSEG
00800 EXTERN ROWPTR,COLPTR,DPYIMG
01000 ISAVED:0
01100
01200 ;POINTERS TO SKY ROWS - COLUMN ACCUMULATOR 3.
01300 SKY: FOR I←0,=216{
01400 $ + =289*I (3) }
01500
01600 DECLARE{IMAGE,LEVEL,POLYGON}
00100 ;MKCON(Q1,Q2). MAKE CONTOUR IMAGE: VIDEO → CONTOUR.
00200 SUBR(MKCON)Q1,Q2 ----------------------------------------------
00300 BEGIN MKCON
00400
00500 ;BIT POSITIONS OF THE ARGUMENTS Q1 & Q2 ENABLE INTENSITY CUTS.
00600 LAC 1,ARG2↔DAC 1,Q0
00700 LAC 1,ARG1↔ANDCMI 1,377↔DAC 1,Q1
00800 SETZM CUT#
00900
01000 ;MAKE THE IMAGE BLOCK AND THE LEVEL -1 FRAME POLYGON.
01100 SETQ IMAGE,{MKIMAG,FILM}
01200 SETQ LEVEL,{MKLEVL,IMAGE,[-1]}
01300 SETQ POLYGON,{MKSKY,LEVEL} ;BORDER & SKY.
01400 CALL(SEGTV)
01500
01600 ;FIND AN INTENSITY CONTOUR ENABLE BIT.
01700 L0: LAC 0,Q0↔LAC 1,Q1
01800 L1: AOS 2,CUT↔LSHC 0,1↔JUMPL 0,L2
01900 CAMN 0,1↔JUMPE 0,L5↔GO L1
02000
02100 ;THRESHOLD THE TVBUF
02200 L2: DAC 0,Q0↔DAC 1,Q1
02300 CALL(THRESH,CUT)
02400 CALL(PACXOR)
02500
02600 ;MAKE LEVEL NODE WITH A RING OF POLYGON NODES.
02700 SETQ(LEVEL,{MKLEVL,IMAGE,CUT})
02800 L3: SETQ(POLYGON,{MKPGON,LEVEL})
02900 JUMPN 1,L3↔LAC 1,LEVEL↔SON 1,1↔JUMPE 1,L0
03000
03100 ;LEVEL OPERATIONS.
03200 L4: CALL(VICONT,LEVEL)
03300 CALL(KLBABY,LEVEL)
03400 CALL(SMOOTH,LEVEL)
03500 CALL(ARCONT,LEVEL)
03600 CALL(MKTREE,LEVEL)
03700 CALL(KILVIC,LEVEL)
03800 CALL(STADPY)
03900 GO L0
04000
04100 ;IMAGE OPERATIONS.
04200 L5: SETZ↔SKIPE FLGKRK↔CORE2↔JFCL ;KILL SKY ARRAY.
04300 LAC 1,LEVEL↔CCW 1,1
04400 CALL(KILVIC,1)
04500 LAC 1,IMAGE↔POP2J
04600
04700 DECLARE{Q0,Q1}
04800 BEND MKCON; BGB 6 DECEMBER 1972 ----------------------------------
00100 ;MKIMAG(FILM). MKLEVL(IMAGE,CUT).
00200 SUBR(MKIMAG)FILM--------------------------------------------------
00300 BEGIN MKIMAG; MAKE IMAGE NODE - BGB - 10 JANUARY 1973.
00400 SETQ(IMAGE,{MKNODE,[IBIT+IMGREL]})
00500 CALL(RINGIN,IMAGE,FILM)
00600 LAC 1,IMAGE↔LAC 2,FILM
00700 SON. 1,2↔DAD. 2,1
00800 LIPI 1,(1)↔DAC 1,3(1)↔DAC 1,4(1)↔DAC 1,5(1) ;FEV-RINGS.
00900 POP1J
01000 BEND;1/10/73------------------------------------------------------
01100
01200 SUBR(MKLEVL)IMAGE,CUT---------------------------------------------
01300 BEGIN MKLEVL; MAKE LEVEL NODE - BGB - 10 JANUARY 1973.
01400 SETQ(LEVEL,{MKNODE,[LBIT+LVLREL]})
01500 CALL(RINGIN,LEVEL,IMAGE)
01600 LAC 1,LEVEL↔LAC 2,IMAGE
01700 LAC 0,ARG1↔NCNT. 0,1
01800 SKIPGE↔SON. 1,2↔DAD. 2,1
01900 POP2J
02000 BEND;1/10/73------------------------------------------------------
00100 ;MKNODE(TYPE). MAKE A NODE.
00200 SUBR(MKNODE)TYPE -------------------------------------------------
00300 BEGIN MKNODE
00400 EXTERN MORCOR,AVAIL,BLKCNT
00500 SKIPN 1,@AVAIL
00600 CALL(MORCOR)
00700 CDR(1)↔DAP @AVAIL
00800 SETZM(1)↔AOS @BLKCNT
00900 POP P,.+3↔POP P,2(1)↔GO @.+1↔0
01000 POP1J
01100 BEND MKNODE; BGB 10 JANUARY 1973 ---------------------------------
01200
01300 ;KLNODE(NODE). KILL A NODE.
01400 SUBR(KLNODE)NODE--------------------------------------------------
01500 BEGIN KLNODE
01600 LAC 1,ARG1
01700 SOS @BLKCNT
01800 SETZM(1)↔LIPI(1)↔LAPI 1(1)↔BLT NODSIZ-1(1)
01900 LAC @AVAIL↔DAPZ(1)↔DAPZ 1,@AVAIL
02000 POP1J
02100 BEND KLNODE; BGB 17 DECEMBER 1972 --------------------------------
02200
00100 SUBR(RINGIN)PART,WHOLE -------------------------------------------
00200 BEGIN RINGIN
00300 LAC 1,ARG2
00400 LAC 3,ARG1
00500 SON 2,3
00600 JUMPE 2,[SON. 1,3↔DIP 1,(1)↔DAP 1,(1)↔POP2J]
00700 CAR 3,(2)
00800 DIP 3,(1)↔DAP 1,(3)
00900 DAP 2,(1)↔DIP 1,(2)
01000 POP2J↔LIT
01100 BEND RINGIN; BGB 6 DECEMBER 1972 ---------------------------------
00100 ;THRESH(LEVEL). PAXOR.
00200 SUBR(THRESH)------------------------------------------------------
00300 BEGIN THRESH
00400 SKIPE FLGKRK↔DETSEG
00500 ;SOUTH TO PAC FOR PIXELS ≥ CUT.
00600 I←13 ↔ J←14
00700 CALL(SEGTV)
00800 LAC [XWD L,2]↔BLT 13
00900 LAC ARG1↔LSH -3↔DAC HCUT
01000 LAP 5,ARG1
01100 GO 3
01200
01300 ;ACCUMULATOR LOOP.
01400 L: POINT 6,TVBUF,-1
01500 MOVEI J,=36 ;3
01600 ILDB 2 ;4
01700 SUBI ;CUT ;5
01800 ROTC 1 ;6
01900 SOJG J,4 ;7
02000 SETCAM 1,PAC(I) ;10
02100 AOBJN I,3 ;11
02200 POP1J ;12
02300 XWD -=1728,0 ;13
02400 BEND THRESH;BGB 4 DECEMBER 1972 ----------------------------------
02500
02600 HCUT: 0 ;HCUT GLOBAL FROM THRESH TO MKPGONS.
02700
02800 ;PACXOR. ROOK'S MOVE XOR'ING ON 1-BIT IMAGE.
02900 SUBR(PACXOR)------------------------------------------------------
03000 BEGIN PACXOR
03100 I←2
03200 SLACI PAC↔LAPI HSEG↔BLT HSEG+=1727
03300 SLACI PAC↔LAPI VSEG↔BLT VSEG+=1727
03400 SETZ I,
03500 HRRI PAC↔DAP L+2
03600 L: TRNN I,7↔SETZ 1,↔LAC PAC(I)
03700 XORM HSEG+8(I) ; HSEG SOUBIT are above PAC bits.
03800 ROTC -1↔ROT 1,1
03900 XORM VSEG(I) ; VSEG are left of PAC bits.
04000 AOS I
04100 CAIE I,=1728
04200 GO L
04300 SETZM ISAVED
04400 POP0J
04500 BEND PACXOR; BGB 4 DECEMBER 1972 ---------------------------------
00100 ;HISTOG. BIMOD.
00200 SUBR(HISTOG)---------------------------------------------------
00300 BEGIN HISTOG;MAKE HISTOGRAM OF TVBUF - BGB - 4 DEC 72.
00400
00500 CALL(SEGTV)
00600 SKIPE FTVHIS↔POP0J↔SETOM FTVHIS
00700 LAC[XWD HISTO,HISTO+1]↔SETZM HISTO↔BLT HISTO+77
00800 LAC 7,[XWD L,0]↔BLT 7,6↔GO 2
00900
01000 ;ACCUMULATOR LOOP.
01100 L: =62208 ;0
01200 0 ;1
01300 ILDB 1,6 ;2
01400 AOS HISTO(1) ;3
01500 SOJG 0,2 ;4
01600 POP0J ;5
01700 POINT 6,TVBUF,-1;6
01800
01900 BEND;12/16/72-----------------------------------------------------
02000
02100 SUBR(BIMOD)-------------------------------------------------------
02200 BEGIN BIMOD;BI-MODAL HISTOGRAM CUT HIGH AND CUT LOW - 14 DEC 72.
02300 ACCUMULATORS{Q1,Q2,HI,LO}
02400 CALL(HISTOG)
02500 LACI HI,77↔SETZM LO↔SETZB Q1,Q2
02600 SETZ↔SKIPE CTRL↔GO[INCHRW↔ANDI 17↔GO .+1]
02700 SKIPE META↔GO[INCHRW 1↔ANDI 1,17↔IMULI =10↔ADD 1↔GO .+1]
02800 SKIPN↔LACI 3↔IMULI =62208↔IDIVI =100↔DAC 1
02900
03000 ;COME IN FROM THE EXTREMES 3 PER CENT.
03100 SETZ↔ADD HISTO(LO)↔CAMGE 1↔AOJA LO,.-2
03200 SETZ↔ADD HISTO(HI)↔CAMGE 1↔SOJA HI,.-2
03300 L2: CAML LO,HI↔POP0J
03400 SKIPN FTVSIX↔GO L3
03500
03600 ;LOOK FOR LOCAL MINIMUM.
03700 LAC HISTO(LO)↔CAML HISTO+1(LO)↔AOJA LO,L2
03800 LAC HISTO(LO)↔CAML HISTO-1(LO)↔AOJA LO,L2
03900 LAC HISTO(HI)↔CAML HISTO+1(HI)↔SOJA HI,L2
04000 LAC HISTO(HI)↔CAML HISTO-1(HI)↔SOJA HI,L2
04100
04200 ;CUT 'EM UP AND DISPLAY 'EM.
04300 L3: MOVNS LO↔MOVNS HI
04400 SETZ Q2,↔SLACI Q1,1B18↔LSHC Q1,(LO)
04500 SETZB 0,1↔SLACI 1B18↔LSHC(HI)↔IOR Q1,0↔IOR Q2,1
04600 CALL(MKCON,Q1,Q2)
04700 CALL(DPYIMG)
04800 POP0J
04900 BEND;12/14/72-----------------------------------------------------
00100 ;MKPGON(LEVEL). MAKE POLYGON BY TRACING BIT RASTER BLOB.
00200 SUBR(MKPGON)LEVEL--------------------------------------------------
00300 BEGIN MKPGON;MAKE AN INTENSITY CONTOUR POLYGON - BGB - AUGUST 1972.
00400
00500 ACCUMULATORS{A2,A3,RC.,MASK,I,PTR,D,E,V,PG,BITQ,H1,H2}
00600 LAC H1,HCUT↔LACI H2,7↔SUB H2,H1
00700 LAC I,ISAVED↔CDR PTR,ARG1↔LACI BITQ,VREL
00800 SLACI I↔HRRI PAC↔DAC PACPTR#; PAC POINTER INDEXED BY I.
00900
01000 ;FIND THE ROW & COL OF THE UPPER LEFT MOST VSEG.
01100 L1: SKIPE 1,VSEG(I)↔GO L2
01200 AOS I↔CAIE I,=1728↔GO L1
01300 SETZ 1,↔POP1J;EMPTY.
01400
01500 L2: DAC I,ISAVED↔JFFO 1,.+1↔SLACI MASK,400000
01600 MOVNS 2↔LSH MASK,(2)↔MOVNS 2
01700 LAC RC.,I↔ANDI RC.,7↔IMULI RC.,=36↔ADD RC.,2 ;COLUMN.
01800 LAC I↔LSH -3↔DIP RC.↔LSH RC.,6 ;ROW.
01900
02000 ;DISTINGUISH BLOBS FROM HOLES.
02100 SETZM HOLE#
02200 TDNN MASK,@PACPTR ;HOLE OR BLOB ?
02300 SETOM HOLE# ;HOLE'A'COMING.
02400 SKIPE HOLE↔EXCH H1,H2
02500
02600 ;AND HEAD SOUTH.
02700
02800 SETQ(PG,{MKNODE,[PBIT+PGNREL]})
02900 LAC 0,ARG1↔DAD. 0,PG↔CALL(RINGIN,PG,0)
03000 SKIPE HOLE↔GO[MARK PG,HOLBIT↔GO .+1]
03100 DAC RC.,RCMIN#
03200 SETZM RCMAX#
03300 SETZ V,↔SETZM ECNT#
03400 PUSHJ P,FOLLOW
03500 LAC V,V0
03600 CCW. V,E↔CW. E,V
03700
03800 ;MAKE & RETURN VIC POLYGON.
03900
04000 LAC 1,ECNT↔SKIPE HOLE#↔MOVNS 1
04100 NCNT. 1,PG
04200 LAC V0↔SON. 0,PG ;UPPER MOST LEFT.
04300 LAC V1↔ARC. 0,PG ;LOWER MOST RIGHT.
04400 LAC 1,PG
04500 L3: POP1J
00100 ;MKPGON SUB-OPERATIONS.
00200
00300 DEFINE TRY (SEG,YES) {
00400 LAC SEG(I)↔TDZN MASK↔GO .+3↔DAC SEG(I)↔GO YES}
00500 DEFINE LEFT {SUBI RC.,100↔ROT MASK,1↔CAIN MASK,1↔SOS I}
00600 DEFINE RIGHT {ADDI RC.,100↔ROT MASK,-1↔SKIPG MASK↔AOS I}
00700 DEFINE UP {SUB RC.,[1B11]↔SUBI I,8}
00800 DEFINE DOWN {ADD RC.,[1B11]↔ADDI I,8}
00900
01000 ;CREATE NEW EDGE AND VERTEX OF A VIC.
01100 TURN: 0
01200 AOS TURNS#
01300 ADD D,RC.
01400 AOS 2,ECNT
01500
01600 ;VERTEX
01700 CALL(MKNODE,BITQ)
01800 PGON. PG,1
01900 SKIPN V↔GO[DAC 1,V0#↔DAC 1,V↔GO T2]
02000 DAC 1,V
02100 CCW. V,E↔CW. E,V
02200 T2: DAC D,RC(V)
02300 CAMLE D,RCMAX
02400 GO[DAC D,RCMAX↔DAC V,V1#↔GO .+1]
02500 DAC V,E
02600 GO @TURN
00100 ;THE ALCHEMIST OF MKPGON.
00200 ;converts bits of lead into lines of gold.
00300
00400 NORTH: ADD D,[1B11]↔LIPI BITQ,(NORBIT+VBIT)↔JSR TURN
00500 NORTH2: LEFT↔LAC D,DELPM(H1)↔TRY HSEG,WEST
00600 RIGHT↔UP↔TRY VSEG,NORTH2
00700 DOWN↔LAC D,DELPP(H2)↔TRY HSEG,EAST↔FATAL(NORTH)
00800 NORTH3: LIPI BITQ,(NORBIT+VBIT)↔JSR TURN↔LEFT
00900 NORTH4: UP↔LAC D,DELPM(H1)↔TRY HSEG,WEST↔GO NORTH4
01000
01100
01200 WEST: ADDI D,100↔LIPI BITQ,(WESBIT+VBIT)↔JSR TURN
01300 WEST2: CAMN RC.,RCMIN↔POPJ P,
01400 FOLLOW: LAC D,DELPP(H1)↔TRY VSEG,SOUTH
01500 LEFT↔TRY HSEG,WEST2
01600 RIGHT↔UP↔LAC D,DELMP(H2)↔TRY VSEG,NORTH↔FATAL(WEST)
01700
01800
01900 SOUTH: LIPI BITQ,(SOUBIT+VBIT)↔JSR TURN
02000 SOUTH2: DOWN↔LAC D,DELMP(H1)
02100 CAR RC.↔CAIN =216B29↔GO EAST3
02200 TRY HSEG, EAST↔TRY VSEG,SOUTH2
02300 LEFT↔LAC D,DELMM(H2)↔TRY HSEG,WEST↔FATAL(SOUTH)
02400
02500
02600 EAST: LIPI BITQ,(EASBIT+VBIT)↔JSR TURN
02700 EAST2: RIGHT↔LAC D,DELMM(H1)
02800 CDR RC.↔CAIN =288B29↔GO NORTH3
02900 UP↔TRY VSEG,NORTH
03000 DOWN↔TRY HSEG,EAST2
03100 LAC D,DELPM(H2)↔TRY VSEG,SOUTH↔FATAL(EAST)
03200 EAST3: LIPI BITQ,(EASBIT+VBIT)↔JSR TURN↔UP
03300 EAST4: RIGHT↔LAC D,DELMM(H1)
03400 CDR RC.↔CAIN =288B29↔GO[DOWN↔GO NORTH3]
03500 TRY VSEG,NORTH↔GO EAST4
03600
03700 ;DEKINKING OFF SETS.
03800
03900 DELPP: FOR I←24,33{XWD I,I↔}
04000 DELPM: FOR I←24,33{XWD I,-I↔}
04100 DELMP: FOR I←24,33{XWD -I,I↔}
04200 DELMM: FOR I←24,33{XWD -I,-I↔}
04300
04400
04500 BEND MKPGON;BGB AUGUST 1972 ---------------------------------------
00100 ;VICONT(LEVEL). VECTOR INTENSITY CONTRAST.
00200 SUBR(VICONT)LEVEL-------------------------------------------------
00300 BEGIN VICONT
00400 ACCUMULATORS{R1,C1,V1,R2,C2,V2,PG,QQNW,QQSE,CNT,PTR,SAVCNT}
00500 CALL(SEGTV)
00600 LAC 1,ARG1↔SON PG,1↔DAC PG,PG0# ;FIRST POLYGON.
00700 L1: SON V2,PG↔DAC V2,V0# ;FIRST VECTOR.
00800 LAC RC(V2)↔ADD[XWD 40,40]
00900 CAR R2,↔LSH R2,-6
01000 CDR C2,↔LSH C2,-6
01100
01200 L2: LAC V1,V2↔LAC R1,R2↔LAC C1,C2↔CCW V2,V2 ;NEXT VECTOR.
01300 LAC RC(V2)↔ADD[XWD 40,40]
01400 CAR R2,↔LSH R2,-6↔CDR C2,↔LSH C2,-6 ;GET ROW & COL.
01500 SETZB QQNW,QQSE
01600 TESTZ V1,WESBIT↔GO WEST
01700 TESTZ V1,SOUBIT↔GO SOUTH
01800 TESTZ V1,EASBIT↔GO EAST
01900 TESTZ V1,NORBIT↔GO NORTH↔HALT
02000 L3: CAME V2,V0↔GO L2
02100 CCW PG,PG↔CAME PG,PG0↔GO L1 ;NEXT POLYGON.
02200 POP1J
02300 ;-----------------------------------------------------------------
02400 WEST: LAC ROWPTR(R2)↔ADD COLPTR-1(C2)
02500 LAC CNT,C1↔SUB CNT,C2↔CALL(EW)
02600 SUB QQSE,QQNW
02700 NTIME. QQSE,V1↔PTIME. SAVCNT,V1
02800 IDIV QQSE,SAVCNT
02900 CNTRS. QQSE,V1↔GO L3
03000
03100 SOUTH: LAC ROWPTR(R1)↔ADD COLPTR-2(C1)
03200 LAC CNT,R2↔SUB CNT,R1↔CALL(NS)
03300 SUB QQSE,QQNW
03400 NTIME. QQSE,V1↔PTIME. SAVCNT,V1
03500 IDIV QQSE,SAVCNT
03600 CNTRS. QQSE,V1↔GO L3
03700
03800 EAST: LAC ROWPTR(R1)↔ADD COLPTR-1(C1)
03900 LAC CNT,C2↔SUB CNT,C1↔CALL(EW)
04000 SUB QQNW,QQSE
04100 NTIME. QQNW,V1↔PTIME. SAVCNT,V1
04200 IDIV QQNW,SAVCNT
04300 CNTRS. QQNW,V1↔GO L3
04400
04500 NORTH: LAC ROWPTR(R2)↔ADD COLPTR-2(C2)
04600 LAC CNT,R1↔SUB CNT,R2↔CALL(NS)
04700 SUB QQNW,QQSE
04800 NTIME. QQNW,V1↔PTIME. SAVCNT,V1
04900 IDIV QQNW,SAVCNT
05000 CNTRS. QQNW,V1↔GO L3
05100 DECLARE{PTRNW,PTRSE}
05200 ;-----------------------------------------------------------------
00100 ;VICONT CONTINUED.
00200 ;EAST-WEST.
00300 EW: DAC CNT,SAVCNT
00400 TLZ 1↔DAC PTRSE
00500 SUBI=48↔DAC PTRNW
00600
00700 EWL: ILDB PTRNW↔ADDM QQNW
00800 ILDB PTRSE↔ADDM QQSE
00900 SOJG CNT,EWL
01000
01100 CAIG R1,0↔SETZ QQNW,
01200 CAIL R1,=216↔SETZ QQSE,
01300 POP0J
01400
01500 ;NORTH-SOUTH.
01600 NS: DAC CNT,SAVCNT↔TLZ 1↔DAC PTR↔TDCA 1,1
01700
01800 NSL: LACI 1,=48↔ADDB 1,PTR
01900 ILDB 1↔ADDM QQNW
02000 ILDB 1↔ADDM QQSE
02100 SOJG CNT,NSL
02200
02300 CAIG C1,0↔SETZ QQNW,
02400 CAIL C1,=288↔SETZ QQSE,
02500 POP0J
02600
02700 BEND VICONT; BGB 14 DECEMBER 1972 --------------------------------
00100 ;MKSKY(LEVEL). MAKE BORDER POLYGON & SKY ARRAY.
00200 SUBR(MKSKY)LEVEL--------------------------------------------------
00300 BEGIN MKSKY
00400 ACCUMULATORS{R,C,N,S,E,W,M,LVL}
00500
00600 SETQ(M,{MKNODE,[PBIT+PGNREL]})
00700 LAC LVL,ARG1↔DAD. LVL,1
00800 CALL(RINGIN,M,LVL)
00900 LACI R,=216⊗6↔LACI C,=288⊗6
01000
01100 ;VERTEX-POLYGON FRAME.
01200 SETQ(W,{MKNODE,[VBIT+SOUBIT+VREL]})↔PGON. M,W
01300 SETQ(S,{MKNODE,[VBIT+EASBIT+VREL]})↔PGON. M,S
01400 SETQ(E,{MKNODE,[VBIT+NORBIT+VREL]})↔PGON. M,E
01500 SETQ(N,{MKNODE,[VBIT+WESBIT+VREL]})↔PGON. M,N
01600 ROW. R,S↔ROW. R,E↔COL. C,E↔COL. C,N
01700 CW. N,W ↔ CW. E,N ↔ CW. S,E ↔ CW. W,S
01800 CCW. S,W ↔ CCW. E,S ↔ CCW. N,E ↔ CCW. W,N
01900 SON. W,M↔LAC 1,M↔SKIPN FLGKRK↔POP1J
02000
02100 ;MAKE THAT BIG ARRAY UP THERE IN THE SKY.
02200 L1: DETSEG↔LACI =217*=289↔CORE2
02300 GO[FATAL(AIN'T NO MORE CORE UP YONDER.)]
02400 LAC[SIXBIT/SKYSEG/]↔SETNM2↔JFCL
02500 SETZ↔SEGNUM↔DAC SKYSEG
02600
02700 ;PUT THE FRAME UP IN THE SKY.
02800 LAC[XWD $,$+1]↔SETZM $↔BLT $+=217*=289-1
02900 L2: SETZ C,↔LACI R,=216↔DAP W,@SKY(R)↔SOJGE R,.-1
03000 LACI R,=216↔LACI C,=288↔DIP S,@SKY(R)↔SOJGE C,.-1
03100 LACI C,=288↔DAP E,@SKY(R)↔SOJGE R,.-1
03200 SETZ R,↔LACI C,=288↔DIP N,@SKY(R)↔SOJGE C,.-1
03300
03400 ;ARC-POLYGON FRAME.
03500 LACI R,=216⊗6↔LACI C,=288⊗6
03600 CALL(MKNODE,[ARCBIT+VBIT+VREL])↔ARC. 1,W↔ARC. W,1↔LAC W,1
03700 CALL(MKNODE,[ARCBIT+VBIT+VREL])↔ARC. 1,S↔ARC. S,1↔LAC S,1
03800 CALL(MKNODE,[ARCBIT+VBIT+VREL])↔ARC. 1,E↔ARC. E,1↔LAC E,1
03900 CALL(MKNODE,[ARCBIT+VBIT+VREL])↔ARC. 1,N↔ARC. N,1↔LAC N,1
04000 ROW. R,S↔ROW. R,E↔COL. C,E↔COL. C,N
04100 PGON. M,W↔PGON. M,S↔PGON. M,E↔PGON. M,N
04200 CW. N,W ↔ CW. E,N ↔ CW. S,E ↔ CW. W,S
04300 CCW. S,W ↔ CCW. E,S ↔ CCW. N,E ↔ CCW. W,N
04400 ARC. W,M
04500 L3: LAC 1,M↔POP1J
04600 BEND MKSKY; BGB 4 DECEMBER 1972 ----------------------------------
00100 ;MKTREE(LEVEL). MKENDO(P1,P2). KLENDO(P1).
00200 SUBR(MKTREE)LEVEL-----------------------------------------------
00300 BEGIN MKTREE;MAKE POLYGON TREE STRUCTURE USING SKY ARRAY.
00400 ;BGB - 19 DECEMBER 1972.
00500 SKIPN FLGKRK↔POP1J
00600 DETSEG↔LAC SKYSEG
00700 ATTSEG↔GO[FATAL(SKYSEG ATTACH FAILURE IN MKIMAG.)]
00800
00900 ;PLACE POLYGONS OF THIS LEVEL IN THE TREE AND IN THE SKY.
01000 LAC 1,ARG1↔SON 1,1↔DAC 1,PG0#↔DAC 1,POLYGON
01100 L1: CALL(INTREE,POLYGON)
01200 LAC 1,POLYGON
01300 CCW 1,1
01400 DAC 1,POLYGON
01500 CAME 1,PG0↔GO L1
01600 DETSEG↔POP1J
01700 BEND;1/23/73------------------------------------------------------
01800
01900 SUBR(MKENDO)P1,P2-----------------------------------------------
02000 BEGIN MKENDO;PLACE P1 WITHIN P2 - BGB - 23 JANUARY 1973.
02100 LAC 1,ARG2↔LAC 2,ARG1
02200 EXO. 2,1↔ENDO 3,2 ;EXO(P1)←P2;P3←ENDO(P);
02300 JUMPN 3,.+5 ;IF P3=0 THEN BEGIN
02400 ENDO. 1,2↔PGON. 1,1 ;ENDO(P2)←NGON(P1)←PGON(P1)←P1;
02500 NGON. 1,1↔POP2J ;RETURN;END;
02600 NGON 4,3 ;P4←NGON(P3);
02700 PGON. 1,4↔NGON. 1,3 ;PGON(P4)←NGON(P3)←P1;
02800 NGON. 4,1↔PGON. 3,1 ;NGON(P1)←P4;PGON(P1)←P3;
02900 POP2J
03000 BEND;1/23/73------------------------------------------------------
03100
03200 SUBR(KLENDO)P1--------------------------------------------------
03300 BEGIN KLENDO;REMOVE P1 FROM THE TREE - BGB - 23 JANUARY 1973.
03400 LAC 1,ARG1
03500 NGON 2,1↔PGON 3,1 ;P2←NGON(P1);P3←PGON(P1);
03600 PGON. 3,2↔NGON. 2,3 ;PGON(P2)←P3;NGON(P3)←P2;
03700 NGON. 1,1↔PGON. 1,1 ;NGON(P1)←PGON(P1)←P1;
03800 CAMN 3,1↔SETZ 3, ;IF P3=P1 THEN P3←NIL;
03900 EXO 2,1↔ENDO 0,2 ;P2←EXO(P1);P0←ENDO(P2);
04000 CAMN 0,1↔ENDO. 3,2 ;IF P0=P1 THEN ENDO(P2)←P3;
04100 POP1J
04200 BEND;1/23/73------------------------------------------------------
00100 ;INTREE(P1). PUT PGON IN THE K-TREE.
00200 SUBR(INTREE)P1----------------------------------------------------
00300 BEGIN INTREE - PUT A POLY IN THE KRAKAUER TREE - BGB 11 DEC 1972.
00400 ACCUMULATORS{R,C,E,LST,P0,P1,P2,P3}
00500 LAC P1,ARG1
00600 SON E,P1↔JUMPE E,POP1J.
00700 LAC RC(E)↔ADD[XWD 40,40]
00800 CAR R,↔LSH R,-6
00900 CDR C,↔LSH C,-6
01000 TESTZ P1,HOLBIT↔SOS C
01100
01200 ;FIND THE VERTICAL EDGE DUE EAST OF HERE.
01300 L0: SKIPN 1,@SKY(R)↔SOJA C,L0
01400 TRNN 1,-1↔SOJA C,L0
01500 PGON P2,1↔CAMN P2,P1↔SOJA C,L0
01600
01700 ;PLACE P1 WITHIN P2, IN THE TREE AND IN THE SKY.
01800 TEST 1,SOUBIT↔EXO P2,P2
01900 CALL(MKENDO,P1,P2)
02000 CALL(INSKY,P1)
02100
02200 ;CONS UP LIST OF P2'S ENDO POLYGONS.
02300 LAC P1,ARG1↔HRLOI LST,0 ;LIST ← NIL.
02400 EXO P2,P1↔ENDO P3,P2↔JUMPE P3,POP1J. ;AIN'T NONE.
02500 DAC P3,P0
02600 L1: CAMN P3,P1↔GO L2
02700 PTIME. LST,P3↔LAC LST,P3 ;CONS P3 TO LIST.
02800 L2: NGON P3,P3↔CAME P3,P0↔GO L1 ;CDR THE RING.
02900
00100 ;INTREE CONTINUED.
00200 ;SCAN LIST FOR P1 ENDO POLYGONS. P2←CDR(LIST).
00300 L3: CAIN LST,-1↔SETZ LST,
00400 SKIPN P2,LST↔POP1J↔SON E,P2
00500 LAC RC(E)↔ADD[XWD 40,40]
00600 CAR R,↔LSH R,-6
00700 CDR C,↔LSH C,-6
00800
00900 ;SCAN FOR FIRST POLYGON TO THE EAST OF P2.
01000 L4: JUMPL C,L7
01100 SKIPN 1,@SKY(R)↔SOJA C,L4
01200 TRNN 1,-1↔SOJA C,L4
01300 PGON P3,1↔CAMN P3,LST↔SOJA C,L4
01400 TESTZ 1,SOUBIT↔GO L5 ;SKIP ON BRO. GO ON DAD.
01500
01600 ;IF BROTHER IS NOT ON THE P-LIST THEN EXO(P3) IS VALID.
01700 L4A: LAC P0,P3↔EXO P3,P3
01800 PTIME 0,P0↔JUMPE 0,L5
01900 ;IF BROTHER IS ON P-LIST THEN EXO(P3) IS NOT YET VALID AND MUST
02000 ;BE SAVED ON AN N-LIST.
02100 NTIME 0,P0↔NTIME. 0,P2
02200 NTIME. P2,P0↔GO L6
02300
02400 ;CHECK FOR P1 CAPTURE OF P2. P3 IS THE SKY-EXO(P2).
02500 L5: EXO 0,P2
02600 CAMN 0,P3↔GO L6 ;EXO(P2)=SKYEXO(P2).
02700 CALL(KLENDO,P2)
02800 CALL(MKENDO,P2,P1)
02900
03000 ;CAPTURE OLDER BROTHER OFF THE N-LIST OF P2.
03100 L6: LAC 1,P2↔SETZ
03200 NTIME P2,P2
03300 NTIME. 0,1
03400 JUMPN P2,L5
03500
03600 ;CDR THE P-LIST OF POTENTIAL ENDO POLYGONS.
03700 L7: LAC 1,LST↔SETZ
03800 PTIME LST,LST↔PTIME. 0,1
03900 GO L3
04000 BEND;1/23/73------------------------------------------------------
00100 ;INSKY(PGON). PUT A POLYGON IN THE SKY.
00200 SUBR(INSKY)PGON---------------------------------------------------
00300 BEGIN INSKY
00400 ACCUMULATORS{R,C,R2,C2,E,E2}
00500 ;XWD HORIZONTAL,,VERTICAL.
00600 LAC 1,ARG1↔SON E,1↔DAC E,E0#↔JUMPE E,POP1J.
00700 DEFINE ADVANCE{
00800 LAC E,E2↔LAC R,R2↔LAC C,C2
00900 CCW E2,E2↔LAC RC(E2)↔ADD[XWD 40,40]
01000 CAR R2,↔LSH R2,-6
01100 CDR C2,↔LSH C2,-6}
01200 CW E2,E↔ADVANCE↔ADVANCE↔GO SSA
01300
01400 ;SOUTH ↓ BOUND.
01500 S0: CAMN E,E0↔POP1J
01600 SSA: CDR 1,@SKY(R)↔EXO. 1,E
01700 S1: CDR 1,@SKY(R)↔DAP E,@SKY(R)↔JUMPE 1,.+6
01800 ROW 0,1↔ADDI 40↔LSH -6↔CAMN 0,R↔ENDO. E,1
01900 CAIE R2,(R)1↔AOJA R,S1↔ADVANCE
02000 TEST E,EASBIT↔GO W0↔GO EE0
02100
02200 ;NORTH ↑ BOUND.
02300 N0: SOS R↔CDR 1,@SKY(R)↔EXO. 1,E
02400 N1: CDR 1,@SKY(R)↔DAP E,@SKY(R)↔JUMPE 1,.+6
02500 ROW 0,1↔ADDI 40↔LSH -6↔ CAIN 0,(R)1↔ENDO. E,0
02600 CAME R,R2↔SOJA R,N1↔ADVANCE
02700 TEST E,EASBIT↔GO W0↔GO EE0
02800
02900 ;EASTBOUND→.
03000 EE0: CAR 1,@SKY(R)↔EXO. 1,E
03100 EE1: CAR 1,@SKY(R)↔DIP E,@SKY(R)↔JUMPE 1,.+6
03200 COL 0,1↔ADDI 40↔LSH -6↔CAMN 0,C↔ENDO. E,1
03300 CAIE C2,(C)1↔AOJA C,EE1↔ADVANCE
03400 TEST E,NORBIT↔GO S0↔GO N0
03500
03600 ;←WESTBOUND.
03700 W0: SOS C↔CAR 1,@SKY(R)↔EXO. 1,E
03800 W1: CAR 1,@SKY(R)↔DIP E,@SKY(R)↔JUMPE 1,.+6
03900 COL 0,1↔ADDI 40↔LSH -6↔CAIN 0,(C)1↔ENDO. E,1
04000 CAME C,C2↔SOJA C,W1↔ADVANCE
04100 TEST E,NORBIT↔GO S0↔GO N0
04200
04300 BEND INSKY;BGB 7 DECEMBER 1972 -----------------------------------
00100 ;KILVIC(LEVEL). KILL CONTOURS OF THE PREVIOUS LEVEL.
00200 SUBR(KILVIC)LEVEL-------------------------------------------------
00300 BEGIN KILVIC
00400 ACCUMULATORS{PG,E0,E1,E2,PG0}
00500
00600 SKIPN FLGARC↔POP1J ;MAKE ARC ENABLE.
00700 SKIPN FLGU↔POP1J
00800 LAC 1,ARG1↔CW 1,1
00900 SON PG,1
01000 SKIPN PG0,PG↔POP1J
01100
01200 ;RELEASE VIC NODES OF THE POLYGON.
01300 L1: SON E0,PG
01400 JUMPE E0,L3
01500 SETZ↔SON. 0,PG
01600 LAC E1,E0
01700 L2: CCW E2,E1
01800 SETZ 0↔ARC 1,E1↔SKIPE 1↔ARC. 0,1
01900 CALL(KLNODE,E1)
02000 CAMN E2,E0↔GO L3
02100 LAC E1,E2↔GO L2
02200
02300 ;ADVANCE TO NEXT POLYGON ON THIS LEVEL.
02400 L3: CCW PG,PG
02500 CAME PG,PG0↔GO L1
02600 POP1J
02700
02800 BEND KILVIC; BGB 5 JANUARY 1973 ----------------------------------
00100 ;KLBABY(LEVEL). KILL BABY POLYGONS OF A LEVEL.
00200 SUBR(KLBABY)LEVEL ------------------------------------------------
00300 BEGIN KLBABY
00400 ACCUMULATORS{A,PG,E0,E1,E2,Q,R}
00500 SKIPN FLGBK↔POP1J
00600 LAC 1,ARG1↔SON PG,1↔DAC PG,PG0#
00700 ;KLUDGE - SPARE SON POLYGON UNTIL WE CAN THINK OF A POLICY.
00800 GO L3
00900 ;ELIMINATE INSIGNIFICANT CONTOURS - SMALL LOW CONTRAST.
01000 L1: NCNT 0,PG↔LACM
01100 CAIL =10↔GO L3
01200
01300 ;RELEASE VIC NODES OF THE POLYGON.
01400 SON E0,PG
01500 LAC E1,E0
01600 L2: CCW E2,E1
01700 CALL(KLNODE,E1)
01800 CAMN E2,E0↔GO .+3
01900 LAC E1,E2↔GO L2
02000
02100 ;KILL A BABY POLYGON.
02200 CAR Q,(PG)↔CDR R,(PG)
02300 DIP Q,(R)↔ DAP R,(Q) ;RINGO PG.
02400 CALL(KLNODE,PG)
02500 SKIPA PG,R ;CCW FROM OUT OF THE GRAVE.
02600
02700 ;ADVANCE TO NEXT POLYGON ON THIS LEVEL.
02800 L3: CCW PG,PG↔CAME PG,PG0↔GO L1
02900 POP1J
03000
03100 BEND;1/6/73------------------------------------------------------
00100 ;KLPGON(PGON).
00200 SUBR(KLPGON)POLYGON-----------------------------------------------
00300 BEGIN KLPGON;KILL POLYGON RETURN CCW(PGN) - BGB - 7 JANUARY 1973.
00400 ACCUMULATORS{PG,E0,E1,E2,Q,R}
00500 LAC PG,ARG1
00600
00700 ;RELEASE VIC NODES OF THE POLYGON.
00800
00900 SON E0,PG
01000 LAC E1,E0
01100 L1: CCW E2,E1
01200 CALL(KLNODE,E1)
01300 CAMN E2,E0↔GO .+3
01400 LAC E1,E2↔GO L1
01500
01600 ;RING OUT & KILL POLYGON NODE,
01700
01800 NGON Q,PG↔PGON R,PG↔JUMPE R,L2
01900 NGON. Q,R↔PGON. R,Q↔CAMN PG,R↔SETZ R,
02000 EXO 1,PG↔JUMPE 1,.+4↔ENDO 0,1↔CAMN 0,PG↔ENDO. R,1
02100 ENDO 1,PG↔SKIPE 1↔ZIP 3(1) ;MY ENDO BECOMES AN ORPHAN.
02200
02300 L2: CAR Q,(PG)↔CDR R,(PG)
02400 DIP Q,(R)↔ DAP R,(Q) ;RINGO PG.
02500 CALL(KLNODE,PG)
02600
02700 ;DOES DAD NEED A NEW FIRST SON.
02800
02900 DAD 1,R
03000 CAMN PG,R↔SETZ R,
03100 SON 0,1↔CAMN 0,PG↔SON. R,1
03200
03300 ;RETURN PGON CCW FROM OUT OF THE GRAVE.
03400 LAC 1,R
03500 POP1J
03600
03700 BEND;1/8/73------------------------------------------------------
00100 ;SMOOTH(LEVEL).
00200 SUBR(SMOOTH)LEVEL-------------------------------------------------
00300 BEGIN SMOOTH; -BGB- 6 DEC 1972.
00400 ACCUMULATORS{V1,V2,PG,E0,E1,E2}
00500 SKIPN FLGARC↔POP1J ;MAKE ARC ENABLED ?
00600 LAC 1,ARG1
00700 SON PG,1↔SKIPN PG↔POP1J
00800
00900 ;POLYGON INITIALIZATION.
01000
01100 L1: DAC PG,PGSAVE#
01200 SON V1,PG↔DAC V1,E0SAVE# ;UPPER MOST LEFT VERTEX.
01300 ARC V2,PG ;LOWER MOST RIGHT VERTEX.
01400 TESTZ V2,ARCBIT↔POP1J ;END OF LEVEL'S POLYGON RING.
01500
01600 ;CREATE ARC NODES AT POLYGON'S EXTREME CORNERS.
01700
01800 SETQ(ARC2,{MKNODE,[VBIT+ARCBIT+VREL]})
01900 LAC RC(V2)↔DAC RC(1)↔ARC. 1,V2↔ARC. V2,1
02000 SETQ(ARC1,{MKNODE,[VBIT+ARCBIT+VREL]})
02100 LAC RC(V1)↔DAC RC(1)↔ARC. 1,V1↔ARC. V1,1
02200
02300 LAC 2,ARC2↔CCW. 1,2↔CW. 1,2↔CCW. 2,1↔CW. 2,1
02400 PGON. PG,1↔PGON. PG,2↔ARC. 1,PG
02500
02600 ;CALL FOR CREATION OF THE INTERMEDIATE ARC NODES.
02700 SETZM AVCNT
02800 CALL(MKARCS,ARC1,ARC2)
02900 CALL(MKARCS,ARC2,ARC1)
03000
03100 ;KILL TWO-SIDED ARC-POLYGONS AND ADVANCE TO NEXT POLYGON.
03200 SKIPN AVCNT↔GO[
03300 SETQ(PG,{KLPGON,PGSAVE})
03400 JUMPN PG,L1↔POP1J]
03500 LAC PG,PGSAVE↔CCW PG,PG↔GO L1
03600
03700 LIT
03800 DECLARE{ARC1,ARC2}
03900 BEND;1/9/73-------------------------------------------------------
04000
04100 DECLARE{AVCNT} ;ARC-VERTEX COUNT.
00100 ;ARCONT(LEVEL). ARC CONTRAST.
00200 SUBR(ARCONT)LEVEL-------------------------------------------------
00300 BEGIN ARCONT;ARC CONTRAST - BGB - 21 JANUARY 1973.
00400 ACCUMULATORS{QNS,QEW,A1,A2,V1,V2,PG,PG0,A0}
00500
00600 ;FOR ALL THE ARCS OF THIS LEVEL.
00700 LAC 1,ARG1
00800 SON PG,1↔DAC PG,PG0 ;FIRST POLYGON.
00900 L1: ARC A2,PG↔DAC A2,A0 ;FIRST ARC.
01000 L2: LAC A1,A2↔ARC V1,A1
01100 CCW A2,A1↔ARC V2,A2
01200
01300 ;ACCUMULATE VECTOR CONTRAST,,LENGTH ALONG THE ARC.
01400 SETZB QNS,QEW
01500 L3: TESTZ V1,NORBIT+SOUBIT↔GO[
01600 ADD QNS,6(V1)↔GO .+2]
01700 ADD QEW,6(V1)
01800 CCW V1,V1
01900 CAME V1,V2↔GO L3
02000
02100 ;COMPUTE ARC CONTRAST: SIN↑2*VERTICAL + COS↑2*HORIZONTAL.
02200 CAR 0,QNS↔FSC 0,233
02300 CDR 1,QNS↔FSC 1,233↔FDVR 0,1
02400 HLLZ 1,6(A1)↔FMPR 0,1↔DAC 0,QNS
02500 CAR 0,QEW↔FSC 0,233
02600 CDR 1,QEW↔FSC 1,233↔FDVR 0,1
02700 HRLZ 1,6(A1)↔FMPR 0,1↔FADR 0,QNS
02800 FIX 0,233000↔CNTRS. 0,A1
02900
03000 CAME A2,A0↔GO L2 ;LAST ARC OF THE POLYGON ?
03100 CCW PG,PG
03200 CAME PG,PG0↔GO L1 ;LAST POLYGON OF THE LEVEL ?
03300 POP1J
03400 BEND;1/21/73------------------------------------------------------
00100 ;SQRT(X). SQUARE ROOT. AC-TRANSPARENT.
00200 SUBR(SQRT)X ------------------------------------------------------
00300 BEGIN SQRT
00400
00500 A←←0 ↔ B←←1 ↔ C←←2
00600 LACM B,ARG1↔JUMPE B,L2
00700 PUSH P,A↔PUSH P,C
00800
00900 ;LET X=F*(2↑2B) WHERE 0.25<F<1.00 THEN SQRT(X)=SQRT(F)*(2↑B).
01000
01100 ASHC B,-=27↔SUBI B,201 ;PUT EXPONENT IN B, FRACTION IN C.
01200 ROT B,-1 ;CUT EXP IN HALF, SAVE ODD BIT.
01300 DAP B,L1↔LSH B,-=35 ;USE THAT ODD BIT.
01400 ASH C,-10↔FSC C,177(B) ;0.25 < FRACTION < 1.00
01500
01600 ;LINEAR APPROXIMATION TO SQRT(F).
01700
01800 DAC C,A
01900 FMP C,[0.8125↔0.578125](B)
02000 FAD C,[0.302734↔0.421875](B)
02100
02200 ;TWO ITERATIONS OF NEWTON'S METHOD.
02300
02400 LAC B,A
02500 FDV B,C↔FAD C,B↔FSC C,-1
02600 FDV A,C↔FADR A,C
02700 L1: FSC A,0↔LAC 1,A
02800 POP P,C↔POP P,A
02900 L2: SUB P,[2(2)]↔GO@2(P)
03000
03100 BEND SQRT; BGB 28 DECEMBER 1972 ----------------------------------
00100 ;MKARCS(V1,V2). MAKE ARCS FROM V1 CCW TO V2.
00200 SUBR(MKARCS)V1,V2-------------------------------------------------
00300 BEGIN MKARCS
00400 ACCUMULATORS{D,U1,U2,V1,V2,A,B,C,U,V}
00500 LAC V1,ARG2↔LAC V2,ARG1
00600 ;CHECK FOR TRIVAIL CASE.
00700 L0: ARC U1,V1↔ARC U2,V2
00800 CCW 0,U1↔CAMN 0,U2↔GO L3
00900
01000 ;COMPUTE NORMALIZED ARC EDGE COEFFICIENTS.
01100 ROW A,V1↔FLO A, ; A ← Y1.
01200 COL B,V2↔FLO B, ; B ← X2.
01300 COL C,V1↔FLO C, ; C ← X1.
01400 ROW D,V2↔FLO D, ; D ← Y2.
01500 LAC 1,B↔FMPR 1,A ; 1 ← X2*Y1.
01600 FSBR A,D↔FSBR B,C ; A ← Y1-Y2. B ← X2-X1.
01700 FMPR C,D↔FSBR C,1 ; C ← X1*Y2 - X2*Y1.
01800 LAC 0,A↔FMPR 0,0↔LAC 1,B↔FMPR 1,1↔FADR 1,0
01900 CALL SQRT,1↔FDVR A,1↔FDVR B,1↔FDVR C,1
02000 LAC 0,A↔FMPR 0,A↔HLLM 0,6(V1)
02100 LAC 0,B↔FMPR 0,B↔HLRM 0,6(V1)
02200
02300 ;SET 'EM UP FOR AN ARC PASS.
02400 ARC U1,V1↔ARC U2,V2
02500 SETZM DMAX#↔SETZM DMIN#
02600 SETZM VMAX#↔SETZM VMIN#↔SETZM MAXCON#
02700 ;GO FROM U1 CCW TO U2 AND FIND THE U FURTHEST OFF THE ARC-EDGE.
02800 L1: CCW U1,U1↔CAMN U1,U2↔GO L2
02900 COL 0,U1↔FLO 0,↔ROW 1,U1↔FLO 1,
03000 FMPR 0,A↔FMPR 1,B↔LAC D,C↔FADR D,0↔FADR D,1
03100 CAMGE D,DMIN↔GO [DAC U1,VMIN↔DAC D,DMIN↔GO .+1]
03200 CAMLE D,DMAX↔GO [DAC U1,VMAX↔DAC D,DMAX↔GO .+1]
03300 ;KEEP TRACK OF MAXIMUM EDGE CONTRAST ALONG ARC.
03400 CNTRST 0,V1↔MOVM↔CAMLE MAXCON↔DAC MAXCON↔GO L1
03500
03600 ;WHEN EXTREMA EXCEED ARCWID[MAXCON] THEN FORM ARC-POINTS.
03700 L2: LAC U,VMIN↔LACM DMIN
03800 CAMGE DMAX↔LAC U,VMAX
03900 CAMGE DMAX↔LAC DMAX
04000 LAC 1,MAXCON↔CAMGE ARCWID(1)↔GO L3
04100 ;OLDE ESPLIT.
04200 SETQ(V,{MKNODE,[VBIT+ARCBIT+VREL]})↔AOS AVCNT
04300 ARC. U,V↔ARC. V,U
04400 LAC RC(U)↔DAC RC(V)↔PGON 0,U↔PGON. 0,V
04500 CCW. V,V1↔CW. V1,V
04600 CCW. V2,V↔CW. V,V2
04700 LAC V2,V↔GO L0
04800
04900 ;ADVANCE CCW AN ARC-EDGE OR EXIT.
05000 L3: CAMN V2,ARG1↔POP2J
05100 LAC V1,V2↔CCW V2,V2↔GO L0
05200 BEND;28/12/72-----------------------------------------------------
00100 ;FARCL(PGON). FIT ARCS LINEAR.
00200 SUBR(FARCL)PGON---------------------------------------------------
00300 BEGIN FARCL; FIT ARCS LINEAR.
00400 X←←1
00500 ACCUMULATORS{Y,SX,SY,XX,YY,XY,N,E,U1,U2,V1,V2}
00600
00700 ;Clear the Locus of all the Arc Vertices.
00800 LAC E,ARG1↔CAR E,1(E)↔DAC E,E0#
00900 CCW V1,E ↔ SETZM RC(V1)
01000 CCW E,V1 ↔ CAME E,E0↔JRST .-4
01100
01200 ;Advance along Polygon.
01300 CW V2,E
01400 L1: LAC V1,V2↔CCW V2,E
01500 ARC U1,V1↔ARC U2,V2
01600 CW U1,U1↔CW U1,U1
01700 CW U1,U1↔CW U1,U1
01800 CW U1,U1↔CW U1,U1
01900 CCW U2,U2↔CCW U2,U2
02000 CCW U2,U2↔CCW U2,U2
02100 CCW U2,U2↔CCW U2,U2
02200
02300 ;Arc Scan Initialization.
02400 LAC [XWD SX,SY]↔SETZ SX,↔BLT N↔JRST .+3
02500 ;Advance along VIC within the ARC.
02600 L2: CCW U1,U1↔CCW U1,U1
02700 ;Accumulate a Point.
02800 CDR X,RC(U1)↔FLO X,↔CAR Y,RC(U1)↔FLO Y,
02900 FAD SX,X ↔ FAD SY,Y
03000 LAC X ↔ FMP Y ↔ FAD XY,0
03100 FMP X,X ↔ FAD XX,X
03200 FMP Y,Y ↔ FAD YY,Y
03300 CAME U1,U2↔AOJA N,L2↔AOS N
00100 ;FITS ARCS LINEAR CONTINUED.
00200 ;COMPUTE SYMMETRIC LEAST SQUARES LINE COEFFICIENTS.
00300 ; Q ← N*XY - SY*SX.
00400 ; A ← Q + SY*SY - N*YY.
00500 ; B ← Q + SX*SX - N*XX.
00600 ; C ← SX*YY + SY*XX - XY*(SX+SY).
00700
00800 L3: LAC 2,SX↔FMP 2,YY
00900 LAC 0,SY↔FMP 0,XX↔FAD 2,0
01000 LAC SX↔FAD SY↔FMP XY↔FSB 2,0↔DAC 2,CCCC#
01100
01200 FSC N,233↔FMP XX,N↔FMP XY,N↔FMP YY,N ;all the N terms.
01300 LAC SX↔FMP SY↔FSB XY,0 ;Q in XY.
01400
01500 FMP SY,SY↔FAD SY,XY↔FSB SY,YY↔DAC SY,AAAA#
01600 FMP SX,SX↔FAD SX,XY↔FSB SX,XX↔DAC SX,BBBB#
01700
01800 FMP SY,SY↔FMP SX,SX↔FAD SX,SY
01900 SLACI(1.0)↔FDVR SX↔DAC QQQQ# ;PSEUDO NORMALIZATION.
02000
02100 ;SOLVE FOR THE LOCII WHERE PERPENDICULARS DROPPED FROM
02200 ;THE ARC-EDGE HIT THE FITTED LINE.
02300 ; Q ← 1/(A*A + B*B).
02400 ; D ← (B*X1 - A*Y1).
02500 ; X ← (B*D - A*C)*Q.
02600 ; Y ←-(A*D + B*C)*Q.
02700
02800 L4: ARC U1,V1
02900 CDR X,RC(U1)↔FLO X,↔CAR Y,RC(U1)↔FLO Y,
03000 FMP X,BBBB↔FMP Y,AAAA↔FSBR X,Y↔LACN Y,X ;DDDD.
03100 FMP X,BBBB↔FMP Y,AAAA
03200 LAC AAAA↔FMP CCCC↔FSBR X,↔FMPR X,QQQQ↔247040226000;FIX
03300 LAC BBBB↔FMP CCCC↔FSBR Y,↔FMPR Y,QQQQ↔247100226000
03400 DIP Y,X↔ADDM X,RC(V1)
03500
03600 ARC U2,V2
03700 CDR X,RC(U2)↔FLO X,↔CAR Y,RC(U2)↔FLO Y,
03800 FMP X,BBBB↔FMP Y,AAAA↔FSBR X,Y↔LACN Y,X ;DDDD.
03900 FMP X,BBBB↔FMP Y,AAAA
04000 LAC AAAA↔FMP CCCC↔FSBR X,↔FMPR X,QQQQ↔247040226000;FIX
04100 LAC BBBB↔FMP CCCC↔FSBR Y,↔FMPR Y,QQQQ↔247100226000
04200 DIP Y,X↔ADDM X,RC(V2)
04300
04400 CCW E,V2↔CAME E,E0↔JRST L1
04500 LAC 12,AC12↔POP1J
04600 BEND;1/6/73-------------------------------------------------------
04700
04800 END